home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacTech 1 to 12
/
MacTech-vol-1-12.toast
/
Tools
/
Alpha 6.51b13 ƒ
/
Tcl
/
Modes
/
perl5.tcl
< prev
next >
Wrap
Text File
|
1997-03-06
|
8KB
|
240 lines
##############################################################################
# Colorization and cmd-dbl-click support for Perl 5
#
# Author: Tom Pollard <pollard@chem.columbia.edu>
# Last modified: 1/1/96
#
# if {![info exists perlDocs]} {
# set perlDocs "$HOME:Help:Perl Docs"
# }
##############################################################################
# Colorization setup
#
# Keywords are separated here according to their location in the Perl 5
# documentation for the convenience of the cmd-double-click mechanism.
#
set perlKeyWords {}
# These are described in the "Compound statements" section of "perlsyn"
#
set words {
continue else elsif for foreach if return unless until while
eq ne cmp lt gt le ge
}
foreach wd $words {
set perlLookup($wd) [list perlsyn {Compound statements}]
}
set perlKeyWords [concat $perlKeyWords $words]
# These are described in the "SYNOPSIS" section of "perlsub"
#
set words { sub }
foreach wd $words { set perlLookup($wd) [list perlsub {SYNOPSIS}] }
set perlKeyWords [concat $perlKeyWords $words]
# These are described in the "Packages" section of "perlmod"
#
set words { package }
foreach wd $words { set perlLookup($wd) [list perlmod {Packages}] }
set perlKeyWords [concat $perlKeyWords $words]
# These are described in the "Package Constructors and Destructors"
# section of "perlmod" and can't be colorized.
#
set words { BEGIN END }
foreach wd $words {
set perlLookup($wd) [list perlmod {Package Constructors and Destructors}]
}
# These are described in the "A Class is Simply a Package"
# section of "perlobj" and can't be colorized.
#
set words { @ISA $ISA }
foreach wd $words {
set perlLookup($wd) [list perlobj {A Class is Simply a Package}]
}
# These are described in the "SYNOPSIS" section of "perlovl" and
# can't be colorized.
#
set words { %OVERLOAD $OVERLOAD }
foreach wd $words { set perlLookup($wd) [list perlovl {SYNOPSIS}] }
# Special variables are described in "perlvar" (and are not all
# individually marked, so we have to search for them.)
#
# This group can safely be colorized...
#
set words {
$_ $1 $2 $3 $4 $5 $6 $7 $8 $9 $& $` $' $+ $* $. $/ $| $, $\\ $" $; $# $%
$= $- $~ $^ $: $? $! $@ $$ $< $> $( $) $0 $[ $]
}
foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
set perlKeyWords [concat $perlKeyWords $words]
#... while this group is forced lower-case by the current colorization scheme
#
set words {
$ARG $MATCH $PREMATCH $POSTMATCH $LAST_PAREN_MATCH $MULTILINE_MATCHING
$INPUT_LINE_NUMBER $NR $INPUT_RECORD_SEPARATOR $RS $OUTPUT_AUTOFLUSH
$OUTPUT_FIELD_SEPARATOR $OFS $OUTPUT_RECORD_SEPARATOR $ORS
$LIST_SEPARATOR $SUBSCRIPT_SEPARATOR $SUBSEP $OFMT $FORMAT_PAGE_NUMBER
$FORMAT_LINES_PER_PAGE $FORMAT_LINES_LEFT $FORMAT_NAME $FORMAT_TOP_NAME
$FORMAT_LINE_BREAK_CHARACTERS $FORMAT_FORMFEED $^L $ACCUMULATOR $^A
$CHILD_ERROR $OS_ERROR $ERRNO $EVAL_ERROR $PROCESS_ID $PID $REAL_USER_ID
$UID $EFFECTIVE_USER_ID $EUID $REAL_GROUP_ID $GID $EFFECTIVE_GROUP_ID
$EGID $PROGRAM_NAME $PERL_VERSION $DEBUGGING $^D $SYSTEM_FD_MAX $^F
$INPLACE_EDIT $^I $PERLDB $^P $BASETIME $^T $WARNING $^W
$EXECUTABLE_NAME $^X $ARGV @ARGV @INC %INC $INC $ENV $SIG %ENV %SIG
}
foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
# These are also described in "perlvar", despite being functions.
#
set words {
input_line_number input_record_separator autoflush
output_field_separator output_record_separator format_page_number
format_lines_per_page format_lines_left format_name format_top_name
format_line_break_characters format_formfeed
}
foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
set perlKeyWords [concat $perlKeyWords $words]
# These are described in "perlfunc"
#
set words {
abs accept alarm atan2 bind binmode bless caller chdir chmod chomp
chop chown chr chroot close closedir connect cos crypt dbmclose dbmopen
defined delete die do dump each eof eval exec exists exit exp fcntl
fileno flock fork formline getc getlogin getpeername getpgrp getppid
getpriority getpwnam getgrnam gethostbyname getnetbyname getprotobyname
getpwuid getgrgid getservbyname gethostbyaddr getnetbyaddr
getprotobynumber getservbyport getpwent getgrent gethostent getnetent
getprotoent getservent setpwent setgrent sethostent setnetent
setprotoent setservent endpwent endgrent endhostent endnetent
endprotoent endservent getsockname getsockopt glob gmtime goto grep hex
import index int ioctl join keys kill last lc lcfirst length link listen
local localtime log lstat m map mkdir msgctl msgget msgsnd msgrcv my
next no oct open opendir ord pack pipe pop pos print printf push q qq qx
qw quotemeta rand rand read readdir readlink recv redo ref rename
require reset return reverse rewinddir rindex rmdir s scalar seek
seekdir select select semctl semget semop send setpgrp setpriority
setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep
socket socketpair sort splice split sprintf sqrt srand stat study substr
symlink syscall sysread system syswrite tell telldir tie time times tr
truncate uc ucfirst umask undef unlink unpack untie unshift use utime
values vec wait waitpid wantarray warn write y
}
foreach wd $words { set perlLookup($wd) [list perlfunc $wd] }
set perlKeyWords [concat $perlKeyWords $words]
regModeKeywords -e {#} -c red -k blue -s [set PerlmodeVars(stringColor)] Perl $perlKeyWords
unset perlKeyWords
set perlKeyWords [array names perlLookup]
##############################################################################
# Cmd-double-click support for Perl mode. (modified for Perl 5 doc structure)
#
proc PerlDblClick {from to} {
global HOME perlKeyWords perlLookup perlDocs perlVersion
global perlSearchPath
set pc [lookAt [expr $from - 1]]
set ppc [lookAt [expr $from - 2]]
set tc [lookAt $to]
# Extend selection to include special characters
#
if {$pc == {$}} {
if {$from == $to} { incr to }
incr from -1
if {$tc == {^}} { incr to }
} elseif {$pc == {^} && $ppc == {$}} {
incr from -2
} elseif {$pc == {%} || $pc == {@}} {
incr from -1
}
# Return if there's no selected text
if {$to > $from} {
select $from $to
set text [getSelect]
set qtext [quoteExpr $text]
} else {
return
}
# alertnote "\"$text\""
set perlSearchPath {}
# Function call
if {$pc == "&"} {
if {![catch {search -f 1 -r 1 -m 0 -s "sub *$qtext *\{" 0} mtch]} {
pushMark
eval select $mtch
message "Use Ctl-. to return to original position"
} else {
message {Sub definition not found}
}
# Look up keywords in the man page by their file marks
} elseif {[lsearch -exact $perlKeyWords $text] >= 0} {
set file [lindex $perlLookup($text) 0]
set mark [lindex $perlLookup($text) 1]
openFileQuietly "$perlDocs:$file"
podFindMark "$mark"
# If user clicked the arg of a 'require' command, open the file
} elseif {![catch {perlFindRequire $from $to} filename]} {
openPerlFile $filename
# Other
} else {
select $from $to
message {Command-double-click on keywords, special vars, and req'd filenames}
}
}
#############################################################################
# These last two procs are duplicated from "pod.tcl", so that that file
# doesn't have to be loaded in order simply to reference the Perl 5 docs
#
proc podFindMark {mark} {
global podMarkIndent
set mark0 $mark
set marks [getNamedMarks -n]
regsub -all {[\/\(\)<>^]} $mark { } mark
set mark [quoteExpr3 $mark]
set item [lsearch -regexp $marks " *${mark}"]
if {$item >= 0} {
gotoMark [lindex $marks $item]
} elseif {![catch {search -f 1 -r 1 -i 0 -m 0 -s " *${mark}" 0} mtch]} {
goto [lindex $mtch 0]
} else {
message "Couldn't locate the section for \"$mark0\""
}
}
proc quoteExpr3 str {
regsub -all {\\} $str {\\\\} str
regsub -all {\|} $str {\|} str
regsub -all {\*} $str {\\*} str
regsub -all {\+} $str {\\+} str
regsub -all {\?} $str {\\?} str
regsub -all {\$} $str {\\$} str
regsub -all {\(} $str {\\(} str
regsub -all {\)} $str {\\)} str
regsub -all {\{} $str "\\\{" str
regsub -all {\}} $str "\\\}" str
regsub -all {\[} $str {\\[} str
regsub -all {\]} $str {\\]} str
return $str
}